home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / herald.t < prev    next >
Text File  |  1988-05-02  |  5KB  |  115 lines
  1. (herald herald (env tsys))
  2.  
  3. ;;; HERALD parsing cruft!
  4.  
  5. ;;; The CADR of a HERALD is just a filespec.  E.g.
  6. ;;;            (HERALD (TSYS LOAD T 54) ...)
  7. ;;;   or even  (HERALD #[Filename YALE-RING TSYS LOAD T 54] ...)
  8. ;;; This is the filespec for "what the file thinks it is."  It may be
  9. ;;; different from the place where the file is actually living.
  10.  
  11. ;;; The parsed-HERALD structure.
  12.  
  13. (define-structure-type herald
  14.     filename        ;Filename, or whatever.
  15.     read-table      ;An expression specifying a read table.
  16.     syntax-table    ;An expression specifying a syntax table.
  17.     support         ;Expression specifying early binding environment.
  18.     environment     ;An expression specifying environment into which to load.
  19.                     ; (Actually, not yet; this is still compatible with 2.7.)
  20.     language        ;Expression evaluating to a "language," whatever that is.
  21.     )
  22.  
  23. (let ((h (stype-master herald-stype)))
  24.   (set (herald-read-table   h) nil)
  25.   (set (herald-syntax-table h) nil)
  26.   (set (herald-support      h) nil)
  27.   (set (herald-environment  h) nil)
  28.   (set (herald-language     h) nil))
  29.  
  30. (define (make-default-herald filename)
  31.   (let ((h (make-herald)))
  32.     (set (herald-filename  h) (->filename filename))
  33.     h))
  34.  
  35. (lset *herald-items*
  36.       `((read-table   ,herald-read-table   0 context)
  37.         (syntax-table ,herald-syntax-table 1 context)
  38.         (support      ,herald-support      2 context)
  39.         (env          ,herald-environment  3 context)
  40.         (language     ,herald-language     4 context)))
  41.  
  42. ;;; Parse a HERALD.  Returns a HERALD structure.
  43.  
  44. (define (parse-herald filespec clauses)
  45.   (let ((h (make-herald))
  46.         (clause-ordinal (lambda (c)
  47.                           (cond ((and (pair? c)
  48.                                       (assq (car c) *herald-items*))
  49.                                  => caddr)
  50.                                 (else 1000)))))
  51.     (set (herald-filename h)
  52.          (cond ((null? filespec) nil)
  53.                ((filespec? filespec) (->filename filespec))
  54.                (else
  55.                 (syntax-error "bad filespec in ~s form~%  ~s"
  56.                               'herald
  57.                               `(herald ,filespec ,@clauses))
  58.                 nil)))
  59.     (iterate loop ((l (sort clauses
  60.                             (lambda (c1 c2)
  61.                               (fx< (clause-ordinal c1) (clause-ordinal c2)))))
  62.                    (items *herald-items*)
  63.                    (prev nil))
  64.       (cond ((or (null? items)
  65.                  (null? l)
  66.                  (and (not (null? l))
  67.                       (not (pair? (car l)))))
  68.              (if (not (null? l))
  69.                  (syntax-error "illegal ~s clause(s)~%  ~s"
  70.                                'herald
  71.                                `(herald ,filespec . ,clauses)))
  72.              h)
  73.             ((eq? (caar l) prev)
  74.              (syntax-error "duplicate ~s clause~%  ~s"
  75.                            'herald (car l))
  76.              (loop (cdr l) items prev))
  77.             ((neq? (caar l) (caar items))
  78.              ;; Use default value.
  79.              (loop l (cdr items) nil))
  80.             (else
  81.              (let ((z (car items)) (c (car l)))
  82.                (set ((cadr z) h)
  83.                     (xcase (cadddr z)
  84.                       ((context)
  85.                        (let ((foo (cond ((and (eq? (car c) 'env)
  86.                                               (eq? (cadr c) 't))
  87.                                          'standard-early-binding-env)
  88.                                         ((and (eq? (car c) 'env)
  89.                                               (eq? (cadr c) 'tsys))
  90.                                          'base-early-binding-env)
  91.                                         (else
  92.                                          (cadr c)))))
  93.                          (cond ((null? (cdr c))
  94.                                 (syntax-error "illegal ~s clause~%  ~s"
  95.                                               'herald c))
  96.                                ((null? (cddr c)) foo)
  97.                                (else
  98.                                 `(',augment-context ,foo
  99.                                                     ,@(map (lambda (f) `',f)
  100.                                                            (cddr c)))))))
  101.                       ((boolean) t)))
  102.                (loop (cdr l) (cdr items) (car c))))))))
  103.  
  104. ;++ what is this?
  105. (define-operation (augment-context context . specs)
  106.   (cond ((environment? context)
  107.          (walk (lambda (spec)
  108.                  (*require nil spec context))
  109.                specs)
  110.          context)
  111.         (else
  112.          (error "unimplemented HERALD operation~%  ~S"
  113.                 `(augment-context ,context . ,specs))
  114.          context)))
  115.